home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / U. Mass AI & LISP Tools / MODULES / RULES / Rule-Back.lisp next >
Encoding:
Text File  |  1990-06-25  |  45.5 KB  |  925 lines  |  [TEXT/CCL ]
  1. ; (c) Copyright 1990 by University of Massachusetts. All rights reserved.
  2. ; This software was conceived, designed, and written by Dan Suthers 
  3. ; while supported by the National Science Foundation under grant number
  4. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  5. ; CA.  Partial support was also received from the Office of Naval Research
  6. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  7. ; Mr. Suthers created this software under his own initiative while in an 
  8. ; academic relationship with the University of Massachusetts.  The above
  9. ; copyright notice was a condition placed by University lawyers on approval
  10. ; of distribution of this software by Apple Computer, and is not meant to
  11. ; imply that this software was created in an employment or "work for hire"
  12. ; relationship between the University and Mr. Suthers.
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; File:         Rule-Back.lisp
  15. ; Author:       Dan Suthers
  16. ; Created:      19-Oct-88 21:57:32
  17. ; Modified:     22-Jun-90 02:24:58 (Dan Suthers)
  18. ; Language:     Common Lisp
  19. ; Package:      RULE
  20. ;
  21. ; Description:  Rule-based reasoner built on the pattern matching facilities
  22. ;               of DNET.  Supports forward and backward reasoning.
  23. ;
  24. ;               This file contains only code for back chaining.  See also
  25. ;               Rule-Defs, Rule-Build, and Rule-Forward.
  26. ;               File RULES has documentation.
  27. ;
  28. ; (c) Copyright 1988, by Daniel D. Suthers
  29. ;                        Department of Computer and Information Science
  30. ;                        University of Massachusetts
  31. ;                        Amherst, Massachusetts 01003
  32. ;
  33. ; This software was conceived, designed, and written by Dan Suthers 
  34. ; while supported by the National Science Foundation under grant number
  35. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  36. ; CA.  Partial support was also received from the Office of Naval Research
  37. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  38. ; I wish to acknowledge the generous support of Beverly Woolf, who obtained 
  39. ; the above grants and encouraged me to pursue my own research interests in
  40. ; her lab.  This work would not have been possible without the resources and
  41. ; stimulating environment of the Computer and Information Science department.
  42. ;
  43. ; Permission to use, modify, and distribute this software is granted subject 
  44. ; to the following restrictions and understandings:
  45. ; 1. The file header, including this notice, shall be retained, and may be
  46. ;    extended to include documentation of modifications to the software.
  47. ; 2. This material is for nonprofit educational and research purposes only.
  48. ;    Users are requested, but not required, to inform Mr. Suthers of any 
  49. ;    noteworthy uses of this software.
  50. ; 3. Mr. Suthers and the University of Massachusetts make no warrantee or
  51. ;    representation that the operation of this software will be error free,
  52. ;    and are under no obligation to provide any services.
  53. ; 4. Any user of such software agrees to indemnify and hold harmless Mr.
  54. ;    Suthers and the University of Massachusetts from all claims arising 
  55. ;    out of the use or misuse of this software, or arising out of any 
  56. ;    accident, injury, or damage whatsoever, and from all costs, counsel
  57. ;    fees, and liabilities incurred in or about any such claim, action, or
  58. ;    proceeding brought thereon.
  59. ; 5. All materials and reports developed as a consequence of the use of 
  60. ;    this software shall duly acknowledge such use, in accordance with
  61. ;    the usual standards of acknowledging credit in academic research.
  62. ;
  63. ; Status: Working.  Could use efficiency hacks and added functionality.
  64. ;
  65. ; Changes:
  66. ;   16-Dec-88 To prevent circularity, backchaining not allowed on a rule
  67. ;     with the same bindings already active.
  68. ;   26-Dec-88 Multiple changes to deal with bug in SUPPORT, which was not
  69. ;     substituting subgoal bindings into consequent match bindings, with 
  70. ;     the result that :BIND in an :AND tried to evaluate an unbound variable.
  71. ;   27-Mar-89 Total rewrite.  Eliminated redundant functions and reasoning;
  72. ;     Added SUPPORTED function and :SEQ operator; Near Miss processing of
  73. ;     :AND; and various bugs fixed.
  74. ;   13-Apr-89 Use of dnet::match-internal and dnet:unify replaced with
  75. ;     match-rules and fast-bind, to take advantage of what is known about
  76. ;     matching rules to speed things up.
  77. ;   26-Apr-89 Fixed :OR support tree (which was improperly adjoining arcs).
  78. ;   19-Sep-89 Fixed :LISP SUPPORT bug: TRJ-ARC-MODALITY made all :LISPs 
  79. ;     supported, regardless of outcome. 
  80. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  81. ;
  82. ; To Do:
  83. ;   Improve datum-justification breakdown for conjunctive datum.
  84. ;
  85. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  86. ;
  87. ;                              Program Notes
  88. ;
  89. ; On Transitive Bindings:
  90. ; 
  91. ; At one point I thought I needed a version of SUBSTITUTE-BINDINGS, called
  92. ; SUBSTITUTE-TRANSITIVE-BINDINGS, which iterated the substitution until no
  93. ; more occurred.  This was to deal with ((?:x . ?:y) (?:y . <constant>)).
  94. ; While UNIFY can return such a binding set, I now believe the backchaining
  95. ; code will not allow it.  This arose only because SUPPORT was APPENDING
  96. ; the bindings that matched a goal to a consequent (yielding (?:x . ?:y)) 
  97. ; with those by which the antecedent subgoal was satisfied ((?:y . <constant>)),
  98. ; to give the above "transitive" binding set.  This was a mistake: now SUPPORT
  99. ; works like RETRIEVE by SUBSTITUTING the latter bindings into the former,
  100. ; to yield ((?:x . <constant>)).  Hence, given there are no variables in the
  101. ; data base, direct retrieval from the database cannot produce transitive
  102. ; bindings, and as I've just shown the rule chainer will eliminate all such
  103. ; bindings it produces.
  104. ;
  105. ; On Finding the First Result:
  106. ;
  107. ; I had a parameter :FIND-ALL for the RETRIEVE function.  If NIL, I'd stop
  108. ; at the first result found.  This does not work.  You don't know which way
  109. ; of getting a subgoal will yield bindings consistent with later subgoals,
  110. ; so you need to return all of them for use by other retrieval functions.
  111. ; If you want only some result, you could save consing by writing a version
  112. ; of RETRIEVE which only does substitute-bindings to get the results for 
  113. ; one of the binding sets returned from RETRIEVE-BINDINGS. 
  114. ; 
  115. ;
  116. ; On assumptions enabling FAST-BIND:
  117. ;
  118. ; This replaces DNET:UNIFY when processing result of dnet::match-links
  119. ; for retrieval of backchaining rules.  We rely on what we know about 
  120. ; this matching to use a faster function:
  121. ;
  122. ; 1. The two patterns will always correspond element-wise, i.e. atomic 
  123. ;    non-variables have already been verified to be equal by match-links,
  124. ;    each sublist has the same number of elements, etc.  (We don't use 
  125. ;    dotted endings in rules.) 
  126. ; 2. Variables in each pattern are assumed to be unique and are treated
  127. ;    as such, even if they have the same name.  (This can be done because
  128. ;    we return two binding sets, one for each direction of binding.)
  129. ;    In particular, ?:x in pattern-1 can be bound to ?:x in pattern-2
  130. ;    because each occurance of ?:x is distinct, and we never have to check
  131. ;    for whether a variable occurs inside an expression it is being bound
  132. ;    to.  This will never cause trouble because:
  133. ;    a. Variables ARE unique symbols across rules, so the only way a
  134. ;       symbol will occur in both patterns is if a rule re-invokes itself.
  135. ;    b. We check for circular rule invocations by testing the entire 
  136. ;       binding set against previous sets on active-bindings.
  137. ;    c. Hence the only time a variable symbol will occur in both patterns
  138. ;       is when a rule re-invokes itself with some (but not all) bindings
  139. ;       repeated, so a rule variable will be bound to itself by fast-bind.
  140. ;       It is placed on only one binding list (the first one returned). 
  141. ; 3. As a consequence of 1 and 2, the only way two patterns can fail to 
  142. ;    match is inconsistent binding of a variable in one direction.  Other 
  143. ;    than checking for this, all we have to do is record the bindings. 
  144. ;
  145. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  146.  
  147. (in-package :RULE)
  148.  
  149. (export '(
  150.  
  151.           *support-tree*
  152.  
  153.           retrieve
  154.           support
  155.  
  156.           trj-arc
  157.           trj-arc-p
  158.           trj-arc-bindings
  159.           trj-arc-grounds
  160.           trj-arc-modality
  161.           trj-arc-warrant
  162.  
  163.  
  164.           trj-node
  165.           trj-node-p
  166.           trj-node-bindings
  167.           trj-node-claim
  168.           trj-node-modality
  169.           trj-node-support
  170.  
  171.           ))
  172.  
  173. (require :mappings)
  174. (require :rule-defs)
  175. #+:CCL (require :rule-browser)
  176.  
  177. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  178. ;;;
  179. ;;;                              DATA STRUCTURES
  180. ;;;
  181. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  182.  
  183. (deftype boolean () '(or T null))
  184.  
  185. (defstruct TRJ-NODE
  186.   "Nodes of a tree representing the support generated by backchaining.
  187.     CLAIM:    an expression we are trying to support at this node.
  188.     MODALITY: one of :SUPPORTED or :UNSUPPORTED.
  189.     SUPPORT:  list of TRJ-ARC structures, forming an implicit disjunction."
  190.  
  191.   (CLAIM nil :type list)
  192.   (MODALITY :unsupported :type (member :supported :unsupported))
  193.   (SUPPORT nil :type list))
  194.  
  195. (defstruct TRJ-ARC 
  196.   "Each of these represents one way in which support for a TRJ-NODE has been 
  197.   attempted, by branching to supporting nodes.
  198.     WARRANT: one of :ASSERTED, :AND, :SEQ, :OR, :LISP, :BIND, or a rule name.
  199.     GROUNDS: a list, or a list of lists, of TRJ-NODEs, depending on the CLAIM.
  200.     BINDINGS: a binding set or a list of binding sets.
  201.   :AND, :SEQ for a TRJ-NODE claim of <c1> ... <cN> have grounds ((<g1> ... <gN>))
  202.     and one binding set.
  203.   :OR for claim <d1> ... <dN> has grounds ((<g1> ... <gN>)) and a list of binding 
  204.     sets.
  205.   :BIND for <variable> <expression> has a single binding set binding only the
  206.     <variable>, and <expression> as grounds.
  207.   :LISP for <expression> has null binding set and a TRJ-NODE recording success
  208.     or failure of the expression.
  209.   <Rule> has (<g1> ... <gn>) grounds and a list of respective 
  210.     unifications between the consequent and the claim as bindings.
  211.   :ASSERTED for <pattern> has <expression> as grounds and binding is the single
  212.     binding set unifying the two."
  213.  
  214.   (WARRANT nil :type symbol)
  215.   (GROUNDS nil :type list)
  216.   (BINDINGS nil :type list))
  217.  
  218. ;;; Ways to make nodes and arcs look like they have each other's fields.
  219.  
  220. (defun TRJ-ARC-MODALITY (arc)
  221.   "trj-arc-modality <arc>                                           [Function]
  222.   Returns :supported or :unsupported, depending on the arc's warrant and
  223.   whether there are nodes on the arc's grounds which provide support via
  224.   that warrant. (Eg. for :and, all grounds must be :supported; for :or or
  225.   a rule, at least one must be.)  No argument checking."
  226.   (declare (optimize (safety 1) (space 2) (speed 3)))
  227.   (case (trj-arc-warrant arc)
  228.     ((:asserted :bind) :supported)
  229.     ((:and :seq)
  230.      (if (every #'(lambda (n) (declare (type trj-arc n))
  231.                    (eq (trj-node-modality n) :supported))
  232.                 (trj-arc-grounds arc))
  233.        :supported
  234.        :unsupported))
  235.     ((:lisp)
  236.      (if (eq (trj-node-modality (first (trj-arc-grounds arc))) :supported)
  237.        :supported
  238.        :unsupported))
  239.     ;; Both :OR and rules are disjunctive (rule only has to succeed one way).
  240.     (otherwise
  241.      (if (some #'(lambda (n) (declare (type trj-arc n))
  242.                    (eq (trj-node-modality n) :supported))
  243.                (trj-arc-grounds arc))
  244.        :supported
  245.        :unsupported))))
  246.  
  247. (defun TRJ-NODE-BINDINGS (node)
  248.   "trj-node-bindings <node>                                         [Function]
  249.   Returns a list of binding sets, which includes only the bindings by 
  250.   which <node> succeeds.  No argument checking."
  251.   (declare (optimize (safety 1) (space 2) (speed 3)))
  252.   (mapcan #'(lambda (a) (declare (type trj-arc a))
  253.             (if (eq (trj-arc-modality a) :supported)
  254.               (list (trj-arc-bindings a))))
  255.          (trj-node-support node)))
  256.  
  257. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  258. ;;;
  259. ;;;                      INTERNAL FUNCTIONS AND MACROS
  260. ;;;
  261. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  262.  
  263. ;;; Little Helpers
  264.  
  265. (eval-when (compile eval)
  266.  
  267.   (defmacro LISP-EVAL (forms)
  268.     ;; Escape to LISP: Want to return result of the last form evaluated.  No 
  269.     ;; bindings ever needed, since they're already substituted by backchaining. 
  270.     ;; Making this a macro in case I want to put trace or error protection in. 
  271.     `(eval (cons 'progn ,forms)))
  272.  
  273.   (defmacro SECOND-VALUE (multiple-value-call)
  274.     ;; Return second of two values.
  275.     `(multiple-value-bind
  276.        (first-value second-value)
  277.        ,multiple-value-call
  278.        (declare (ignore first-value))
  279.        second-value))
  280.  
  281.   (defmacro EXTEND-ACTIVE-BINDINGS (bindings1 bindings2 active-bindings)
  282.     ;; Extends the active-bindings list tested by circular bindings.
  283.     `(if (or ,bindings1 ,bindings2)
  284.        (cons (cons ,bindings1 ,bindings2) ,active-bindings)
  285.        ,active-bindings))
  286.  
  287.   (defmacro CIRCULAR-BINDINGS (bindings1 bindings2 active-bindings pattern-p)
  288.     ;; Returns T iff the bindings indicate an active rule has directly or
  289.     ;; indirectly reinvoked itself.
  290.     `(if (or ,bindings1 ,bindings2)
  291.        ;; There are bindings: see if they are active.  Since variables
  292.        ;; are unique to rules, don't have to index active-bindings by rule.
  293.        (member (cons ,bindings1 ,bindings2) ,active-bindings :test #'equal)
  294.        ;; Bindings NIL OK only if there are no variables in goal.  Some
  295.        ;; rules can generate subgoals with same variables as the rule's
  296.        ;; consequent. These subgoals bind to consequent with NIL bindings.
  297.        ,pattern-p))
  298.  
  299.   (defmacro TRACE-BACKWARD-RULE (goal rule-record bindings)
  300.     ;; Print a trace of a backwards application of a rule, if turned on.
  301.     `(if *rule-trace*
  302.        #-:CCL (format *rule-trace* "~&B: ~S <-- ~S -- ~S"
  303.                       ,goal (rule-record-rule-name ,rule-record)
  304.                       (substitute-bindings ,bindings 
  305.                                            (rule-record-pattern ,rule-record)))
  306.        #+:CCL (rule-trace "~&B: ~S <-- ~S -- ~S"
  307.                           ,goal (rule-record-rule-name ,rule-record)
  308.                           (substitute-bindings ,bindings 
  309.                                                (rule-record-pattern ,rule-record)))
  310.        ))
  311.  
  312.   (defmacro MATCH-RULES (goal rules-dnet)
  313.     ;; This imitates dnet::match-internal, the main difference being 
  314.     ;; the use of fast-bind instead of dnet:unify.
  315.     `(let ((consequents nil) (consequent-bindings nil) (reverse-bindings nil))
  316.        (declare (list consequents consequent-bindings reverse-bindings))
  317.        (setf (cdr *consequent-template*) ,goal)
  318.        (dolist (link (the list
  319.                           (dnet::match-links *consequent-template*
  320.                                              (list (dnet::dnet-link
  321.                                                     (the dnet (sm:gets 'dnet ,rules-dnet)))))))
  322.          (declare (list link))
  323.          (multiple-value-bind
  324.            (success binding-1 binding-2)
  325.            (fast-bind *consequent-template* 
  326.                       (dnet-terminal-expr (cdr link)) nil nil)
  327.            (declare (symbol success) (list binding-1 binding-2))
  328.            (when success
  329.              (push (dnet-terminal-expr (cdr link)) consequents)
  330.              (push binding-1 consequent-bindings)
  331.              (push binding-2 reverse-bindings))))
  332.        (values consequents consequent-bindings reverse-bindings)))
  333.  
  334.   ) ; eval-when
  335.  
  336. ;;;-------------------------------------------------------------------
  337. ;;; Maintaining lists of support arcs.
  338.  
  339. (defun MERGE-SUPPORT-ARCS (arcs1 arcs2)
  340.   ;; Unions two lists of support arcs, merging arcs whose warrant and bindings
  341.   ;; are the same, diving in recursively as needed.
  342.   (dolist (arc arcs2 arcs1)
  343.     (declare (type trj-arc arc))
  344.     (setf arcs1 (adjoin-support-arc arc arcs1))))
  345.  
  346. (defun ADJOIN-SUPPORT-ARC (arc arc-list)
  347.   ;; Adds a support arc to a set of arcs. The arc is already a "member" if
  348.   ;; an arc with the same warrant and bindings is.  In that case, merge the
  349.   ;; grounds recursively; else add the arc to the arc-list.
  350.   (let* ((matching-arc
  351.           (first (member arc arc-list
  352.                          :test #'(lambda (a1 a2)
  353.                                    (declare (type trj-arc a1 a2))
  354.                                    (and (eq (trj-arc-warrant a1) 
  355.                                             (trj-arc-warrant a2))
  356.                                         (equal (trj-arc-bindings a1)
  357.                                                (trj-arc-bindings a2))))))))
  358.     (declare (type trj-arc arc))
  359.     (cond (matching-arc
  360.            (setf (trj-arc-grounds matching-arc)
  361.                  (merge-support-arcs (trj-arc-grounds matching-arc)
  362.                                      (trj-arc-grounds arc)))
  363.            arc-list)
  364.           (t (setq arc-list (nconc arc-list (list arc)))))))
  365. ;;;(push arc arc-list)))))
  366.  
  367. ;;;-------------------------------------------------------------------
  368. ;;; Special purpose unification.  See program notes.
  369.  
  370. (defun FAST-BIND (pattern-1 pattern-2 bindings-1 bindings-2)
  371.   ;; Assumes that pattern-1 and pattern-2 correspond element wise, and
  372.   ;; the only way the binding can fail is if one variable is bound more 
  373.   ;; than once, to different elements in the other pattern. 
  374.   (declare (list bindings-1 bindings-2) 
  375.            (optimize (safety 1) (space 2) (speed 3)))
  376.   (cond ((variable-p pattern-1)
  377.          (let ((prev-binding (assoc pattern-1 bindings-1)))
  378.            (if prev-binding
  379.              (if (equal (cdr prev-binding) pattern-2)
  380.                (values t bindings-1 bindings-2)
  381.                (values nil nil nil))
  382.              (values t (cons (cons pattern-1 pattern-2) bindings-1) bindings-2))))
  383.         ((variable-p pattern-2)
  384.          (let ((prev-binding (assoc pattern-2 bindings-2)))
  385.            (if prev-binding
  386.              (if (equal (cdr prev-binding) pattern-1)
  387.                (values t bindings-1 bindings-2)
  388.                (values nil nil nil))
  389.              (values t bindings-1 (cons (cons pattern-2 pattern-1) bindings-2)))))
  390.         ;; If one is a non-variable atom, match-links guarantees the other is an
  391.         ;; equal atom.
  392.         ((atom pattern-1)
  393.          (values t bindings-1 bindings-2))
  394.         (T
  395.          (multiple-value-bind
  396.            (car-success extended-bindings-1 extended-bindings-2)
  397.            (fast-bind (car pattern-1) (car pattern-2) bindings-1 bindings-2)
  398.            (declare (list extended-bindings-1 extended-bindings-2))
  399.            (if car-success
  400.              (fast-bind (cdr pattern-1) (cdr pattern-2) 
  401.                         extended-bindings-1 extended-bindings-2)
  402.              (values nil nil nil))))))
  403.  
  404. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  405. ;;; Backward Chaining
  406.  
  407. ;;;------------------------------------------------------------------------
  408. ;;; Version which returns results like MATCH, without constructing support.
  409.  
  410. (defun RETRIEVE-BINDINGS (goal data-dnet rules-dnet active-bindings)
  411.   ;; Returns all binding sets by which <goal> is satisfied.  Active-bindings
  412.   ;; are currently in effect for backchained rules, used to avoid circularity.
  413.   (declare (list goal active-bindings) (symbol data-dnet rules-dnet)
  414.            (optimize (safety 1) (space 2) (speed 3)))
  415.   (case (first goal)
  416.     ((:and :seq)
  417.      ;; These are treated the same by RETRIEVE, but not by SUPPORT.
  418.      (retrieve-and (rest goal) data-dnet rules-dnet nil active-bindings))
  419.     ((:or)
  420.      (retrieve-or (rest goal) data-dnet rules-dnet active-bindings))
  421.     ((:lisp) 
  422.      ;; Must signal success or failure based on whether result is T or nil.
  423.      ;; Success is an empty binding set: (()); and failure is no binding set: ().
  424.      (if (lisp-eval (rest goal)) (list nil) nil))
  425.     ((:bind)
  426.      ;; The form introduces a new variable.  Assumes that all variables in
  427.      ;; the form to evaluate have been bound.  Return a set of one binding.
  428.      (list (list (cons (second goal) (lisp-eval (cddr goal))))))
  429.     (otherwise
  430.      ;; Combine results from direct match to data-dnet with backchaining results.
  431.      ;; Since only the bindings are needed, call PATTERN-MATCH-LINKS directly 
  432.      ;; instead of MATCH-PATTERN-INTERNAL: this requires duplicating some of the 
  433.      ;; latter's link processing code (see DNET).
  434.      (nconc (mapcar #'(lambda (link) (declare (list link))
  435.                        (second-value
  436.                         (bind-vars goal (dnet-terminal-expr (cdr link)) nil)))
  437.                     (dnet::pattern-match-links
  438.                      goal (list (dnet::dnet-link (sm:gets 'dnet data-dnet)))))
  439.             (retrieve-backchain goal data-dnet rules-dnet active-bindings)))))
  440.  
  441. (defun RETRIEVE-BACKCHAIN (goal data-dnet rules-dnet active-bindings)
  442.   ;; Returns bindings which result from backchaining on the goal.
  443.   (declare (list goal active-bindings)
  444.            (symbol data-dnet rules-dnet) 
  445.            (optimize (safety 1) (space 2) (speed 3)))
  446.  
  447.   ;; Find matching consequents.  Iterate over each of their antecedents (recorded
  448.   ;; in rule-records).  This iteration is over an implicit disjunction, and each 
  449.   ;; consequent & antecedent pair may support new data independently of others.
  450.   (multiple-value-bind
  451.     (consequents consequent-bindings reverse-bindings)
  452.     (match-rules goal rules-dnet)
  453.     (declare (list consequents consequent-bindings reverse-bindings))
  454.  
  455.     ;; Loop for consequents matched, returning binding sets accumulated.
  456.     (do ((cptr consequents         (rest cptr))
  457.          (bptr consequent-bindings (rest bptr))
  458.          (rptr reverse-bindings    (rest rptr))
  459.          (goal-has-variables (pattern-p goal))
  460.          (binding-sets (list :head)))
  461.         ((null cptr) (rest binding-sets))
  462.       (declare (list cptr bptr rptr binding-sets))
  463.  
  464.       ;; Loop for antecedents indexed under this consequent.
  465.       (dolist (rule-record (dnet::expr-info-internal (first cptr) rules-dnet))
  466.         (declare (list rule-record))
  467.         
  468.         ;; The following avoids circularity in rules by preventing repeated bindings.
  469.         (unless (circular-bindings (first bptr) (first rptr) 
  470.                                    active-bindings goal-has-variables)
  471.           (trace-backward-rule goal rule-record (first bptr))
  472.  
  473.           ;; Make appropriate subgoal expression by substituting bindings into
  474.           ;; the current antecedent (the rule-record-pattern), and get bindings
  475.           ;; which satisfy this subgoal.  Then construct bindings to return by 
  476.           ;; substituting these subgoal bindings (which satisfied the antecedent) 
  477.           ;; into consequent bindings (by which the goal matched the backchaining 
  478.           ;; rule).  Consequent bindings has cdr-references to rule variables 
  479.           ;; which are bound in the subgoal bindings, and hence replaced by this 
  480.           ;; substitution.
  481.           (nconc binding-sets
  482.                  (mapcar #'(lambda (subgoal-binding)
  483.                              (declare (list subgoal-binding))
  484.                             (utils:compose-mappings (first bptr) subgoal-binding))
  485.                          (retrieve-bindings
  486.                           (substitute-bindings (first rptr)
  487.                                                (rule-record-pattern rule-record))
  488.                           data-dnet rules-dnet 
  489.                           (extend-active-bindings (first bptr) (first rptr) active-bindings)))))))))
  490.  
  491. (defun RETRIEVE-AND (and-goals data-dnet rules-dnet previous-bindings active-bindings)
  492.   ;; Return all sets of bindings satisfying an :AND or :SEQ expression.
  493.   ;; This is tricky because we have to deal with both multiple ways to satisfy
  494.   ;; each conjunct and ensuring that bindings are consistent across conjuncts.
  495.   ;; (Previous-bindings are from earlier conjuncts in the :and expression, while 
  496.   ;; active-bindings are from active rules.)
  497.   (declare (list and-goals previous-bindings active-bindings) 
  498.            (symbol data-dnet rules-dnet) (optimize (safety 1) (space 2) (speed 3)))
  499.   (if (null and-goals)
  500.     ;; Nothing left to do, but we expected the single previous-bindings to be
  501.     ;; expanded into a set of its extensions, so list it to make a set.
  502.     (list previous-bindings)
  503.     ;; Find all ways to satisfy the first conjunct.  (Previous bindings are assumed
  504.     ;; to have already been substituted into remaining conjuncts, which guarantees
  505.     ;; consistency.)  Extend the previous bindings with each resulting extension
  506.     ;; to the bindings, and recurse to consume remaining conjuncts, substituting
  507.     ;; the appropriate bindings into the remaining conjuncts for each recursion.
  508.     (mapcan #'(lambda (binding-extension)
  509.                 (declare (list binding-extension))
  510.                 ;; Recurse to consume remaining conjuncts, bound by each extension.
  511.                 ;; Note (append binding-extension previous-bindings) didn't work!
  512.                 (retrieve-and 
  513.                  (substitute-bindings binding-extension (rest and-goals))
  514.                  data-dnet rules-dnet (append previous-bindings binding-extension)
  515.                  active-bindings))
  516.             ;; All ways to satisfy the first conjunct.
  517.             (retrieve-bindings 
  518.              (first and-goals) data-dnet rules-dnet active-bindings))))
  519.  
  520. (defun RETRIEVE-OR (or-goals data-dnet rules-dnet active-bindings)
  521.   (declare (list or-goals active-bindings) (symbol data-dnet rules-dnet)
  522.            (optimize (safety 1) (space 2) (speed 3)))
  523.   ;; Since disjunctive, can split into separate calls for each disjunct
  524.   ;; and combine results with no worry about coordinating variables.  
  525.   ;; Don't bother checking for duplicates: that is done elsewhere.
  526.   (mapcan #'(lambda (disjunct) (declare (list disjunct))
  527.               (retrieve-bindings disjunct data-dnet rules-dnet active-bindings))
  528.           or-goals))
  529.  
  530. ;;;------------------------------------------------------------------------
  531. ;;; Version which returns support tree.
  532.  
  533. (defun SUPPORT-ARCS (goal data-dnet rules-dnet record-failure
  534.                                    include-datum-just active-bindings)
  535.   ;; Dispatches analogous to REFERENCE-BINDINGS (see); Returns a list of arcs.
  536.   (declare (list goal active-bindings) (symbol data-dnet rules-dnet)
  537.            (optimize (safety 1) (space 2) (speed 3)))
  538.   (case (first goal)
  539.     ((:and)    (support-and goal data-dnet rules-dnet record-failure
  540.                             include-datum-just active-bindings))
  541.     ((:seq)    (support-seq goal data-dnet rules-dnet record-failure
  542.                             include-datum-just active-bindings))
  543.     ((:or)     (support-or goal data-dnet rules-dnet record-failure
  544.                            include-datum-just active-bindings))
  545.     ((:lisp)   (support-lisp (rest goal) record-failure))
  546.     ((:bind)   (support-bind (second goal) (rest (rest goal))))
  547.     (otherwise (support-pattern goal data-dnet rules-dnet record-failure
  548.                                 include-datum-just active-bindings))))
  549.  
  550. (defun SUPPORT-PATTERN (goal data-dnet rules-dnet record-failure
  551.                                    include-datum-just active-bindings)
  552.   ;; Returns list of arcs supporting (whether directly or by rule application) 
  553.   ;; a goal which doesn't start with an interpreted operator.
  554.   (declare (list goal active-bindings) (symbol data-dnet rules-dnet)
  555.            (optimize (safety 1) (space 2) (speed 3)))
  556.   (let ((success nil) (support-arcs nil))
  557.        (declare (list support-arcs))
  558.        ;; Initialize support list to direct matches in data-dnet.
  559.        (multiple-value-bind
  560.          (results bindings) (dnet::match-pattern-internal goal data-dnet nil)
  561.          (declare (list results bindings))
  562.          (when results
  563.            (setq success t)
  564.            (do ((rptr results (rest rptr)) (bptr bindings (rest bptr)))
  565.                ((null rptr))
  566.              (declare (list rptr bptr))
  567.              (if include-datum-just
  568.                (setf support-arcs 
  569.                      (nconc (datum-justification-arcs (first rptr) (first bptr) data-dnet)
  570.                             support-arcs))
  571.                (push (make-trj-arc :warrant  ':asserted 
  572.                                    :grounds  (list (make-trj-node 
  573.                                                     :claim (first rptr)
  574.                                                     :modality ':supported
  575.                                                     :support nil))
  576.                                    :bindings (first bptr))
  577.                      support-arcs)))))
  578.        ;; Get list of TRJ-ARCs to subtrees from back chaining and add these.
  579.        (multiple-value-bind
  580.          (backchaining-success backchaining-support-arcs)
  581.          (support-backchain goal data-dnet rules-dnet record-failure 
  582.                             include-datum-just active-bindings)
  583.          (declare (list backchaining-support-arcs))
  584.          (if backchaining-success (setq success t))
  585.          ;; Prefer to keep the easier support up front; also preserve order.
  586.          ;; (Do NOT need to test (or backchaining-success record-failure) here!)
  587.          (setf support-arcs 
  588.                (merge-support-arcs support-arcs backchaining-support-arcs)))
  589.        ;; All done.
  590.        (values success support-arcs)))
  591.  
  592. (defun SUPPORT-BACKCHAIN (goal data-dnet rules-dnet record-failure
  593.                                include-datum-just active-bindings)
  594.   ;; Returns a success predicate and arcs to subtrees resulting from back chaining.
  595.   (declare (list goal active-bindings) (symbol data-dnet rules-dnet)
  596.            (optimize (safety 1) (space 2) (speed 3)))
  597.   
  598.   ;; Find matching consequents.  Iterate over each of their antecedents (recorded
  599.   ;; in rule-records).  This iteration is over an implicit disjunction, and each 
  600.   ;; consequent & antecedent pair may support new data independently of others.
  601.   (multiple-value-bind 
  602.     (consequents consequent-bindings reverse-bindings)
  603.     (match-rules goal rules-dnet)
  604.     (declare (list consequents consequent-bindings reverse-bindings))
  605.  
  606.     ;; Loop for consequents matched.
  607.     (do ((cptr consequents         (rest cptr))
  608.          (bptr consequent-bindings (rest bptr))
  609.          (rptr reverse-bindings    (rest rptr))
  610.          (goal-has-variables (pattern-p goal))
  611.          (success nil) (support-arcs nil))
  612.         ((null cptr) (values success support-arcs))
  613.       (declare (list cptr bptr rptr support-arcs))
  614.  
  615.       ;; Loop for antecedents indexed under this consequent.
  616.       (dolist (rule-record (dnet::expr-info-internal (first cptr) rules-dnet))
  617.         (declare (list rule-record))
  618.         
  619.         ;; The following avoids circularity in rules by preventing repeated bindings.
  620.         (unless (circular-bindings (first bptr) (first rptr)
  621.                                    active-bindings goal-has-variables)
  622.           (trace-backward-rule goal rule-record (first bptr))
  623.  
  624.           ;; Substitute bindings to construct subgoals, and substitute returned
  625.           ;; bindings into goal/consequent bindings. See RETRIEVE-BACKCHAIN.
  626.           (let ((subgoal (substitute-bindings (first rptr) 
  627.                                               (rule-record-pattern rule-record))))
  628.             (declare (list subgoal))
  629.             (multiple-value-bind
  630.               (success-this-time new-support-arcs)
  631.               (support-arcs 
  632.                subgoal data-dnet rules-dnet record-failure include-datum-just
  633.                (extend-active-bindings (first bptr) (first rptr) active-bindings))
  634.               (declare (list new-support-arcs))
  635.               (if success-this-time (setq success t))
  636.               (dolist (sa new-support-arcs)
  637.                 (declare (type trj-arc sa))
  638.                 (setf support-arcs 
  639.                       (adjoin-support-arc
  640.                        (make-trj-arc
  641.                         :warrant (rule-record-rule-name rule-record)
  642.                         :grounds  (list (make-trj-node
  643.                                          :claim subgoal
  644.                                          :modality (trj-arc-modality sa)
  645.                                          :support  (list sa)))
  646.                         :bindings (utils:compose-mappings (first bptr)
  647.                                                           (trj-arc-bindings sa)))
  648.                        support-arcs))))))))))
  649.  
  650. ;;; We must return multiple arcs with warrant :AND supporting the goal.  Each 
  651. ;;; arc must have a consistently bound set of support for the conjuncts, and 
  652. ;;; there may be many ways to satisfy the conjuncts.  Conceptually, the idea 
  653. ;;; is to find support for the first conjunct; then split this node into K nodes 
  654. ;;; where K is the number of distinct ways to support it; then recurse to 
  655. ;;; consume remaining conjuncts with each of K bindings substituted into them; 
  656. ;;; then combine the lists of nodes returned.
  657.  
  658. (defun SUPPORT-AND (and-goal data-dnet rules-dnet record-failure
  659.                              include-datum-just active-bindings)
  660.   (declare (list and-goal active-bindings) (symbol data-dnet rules-dnet)
  661.            (optimize (safety 1) (space 2) (speed 3)))
  662.   ;; Just getting things started.
  663.   (support-conjunction-arcs 
  664.    (make-trj-arc :warrant ':and :grounds nil :bindings nil)
  665.    (rest and-goal) data-dnet rules-dnet 
  666.    record-failure include-datum-just active-bindings))
  667.  
  668. ;;; :SEQ will be treated identically except short circuiting on failure.
  669.  
  670. (defun SUPPORT-SEQ (and-goal data-dnet rules-dnet record-failure
  671.                              include-datum-just active-bindings)
  672.   (declare (list and-goal active-bindings) (symbol data-dnet rules-dnet)
  673.            (optimize (safety 1) (space 2) (speed 3)))
  674.   ;; Just getting things started.
  675.   (support-conjunction-arcs 
  676.    (make-trj-arc :warrant ':seq :grounds nil :bindings nil)
  677.    (rest and-goal) data-dnet rules-dnet 
  678.    record-failure include-datum-just active-bindings))
  679.  
  680. (defun SUPPORT-CONJUNCTION-ARCS (arc goals data-dnet rules-dnet record-failure 
  681.                                      include-datum-just active-bindings)
  682.   ;; Takes an AND or :SEQ arc and some goals to be consumed, and returns list of 
  683.   ;; support arcs which constitute the "split" of the arc into its extensions to
  684.   ;; include the remaining conjuncts.
  685.   (declare (list goals active-bindings) (symbol data-dnet rules-dnet)
  686.            (optimize (safety 1) (space 2) (speed 3)))
  687.   (if (null goals)
  688.     (let ((supported (eq (trj-arc-modality arc) ':supported)))
  689.       (values supported (if (or supported record-failure) (list arc))))
  690.  
  691.     ;; Find all ways to satisfy the first conjunct.  Previous bindings are assumed
  692.     ;; to have already been substituted into remaining conjuncts, which guarantees
  693.     ;; consistency.  However, there may still be variables in the conjunct.
  694.     (multiple-value-bind
  695.       (first-conjunct-success support-arcs)
  696.       (support-arcs (first goals) data-dnet rules-dnet record-failure
  697.                     include-datum-just active-bindings)
  698.       (declare (list support-arcs))
  699.       (if (or first-conjunct-success
  700.               (and record-failure (eq (trj-arc-warrant arc) ':and)))
  701.         ;; Split arc into list of arcs, each with extended support and bindings.
  702.         (let ((split-arcs
  703.                (if support-arcs
  704.                  (mapcar
  705.                   #'(lambda (sa) (declare (type trj-arc sa))
  706.                      (make-trj-arc
  707.                       :warrant (trj-arc-warrant arc)
  708.                       ;; Retain conjunct order. Reusing list elsewhere (no nconc).
  709.                       :grounds (append (trj-arc-grounds arc)
  710.                                        (list (make-trj-node
  711.                                               :claim (first goals)
  712.                                               :modality (trj-arc-modality sa)
  713.                                               :support (list sa))))
  714.                       :bindings (append (trj-arc-bindings arc)
  715.                                         (trj-arc-bindings sa))))
  716.                   support-arcs)
  717.                  (list
  718.                   (make-trj-arc
  719.                    :warrant (trj-arc-warrant arc)
  720.                    :grounds (append (trj-arc-grounds arc)
  721.                                     (list (make-trj-node
  722.                                            :claim (first goals)
  723.                                            :modality :unsupported
  724.                                            :support nil)))
  725.                    :bindings (append (trj-arc-bindings arc) (list nil)))))))
  726.           ;; Recurse on remaining conjuncts with each separate binding substituted
  727.           ;; in, then combine results.  (But skip failure arcs in :SEQ.)
  728.           (do ((sa-ptr split-arcs (rest sa-ptr))
  729.                (success nil) (results (list ':head)))
  730.               ((null sa-ptr) (values success (rest results)))
  731.             ;; If the conjunct just consumed is supported, ok to try remainder.
  732.             ;; :AND lets us try even if it is not supported, to build rest of tree.
  733.             (if (or (eq (trj-arc-modality (first sa-ptr)) ':supported)
  734.                     (eq (trj-arc-warrant arc) ':and)) ; record-failure must be true
  735.               (multiple-value-bind
  736.                 (recursive-success recursive-support-arcs)
  737.                 (support-conjunction-arcs 
  738.                  (first sa-ptr) 
  739.                  (substitute-bindings (trj-arc-bindings (first sa-ptr))
  740.                                       (rest goals))
  741.                  data-dnet rules-dnet record-failure 
  742.                  include-datum-just active-bindings)
  743.                 (if recursive-success (setq success t))
  744.                 (when (or recursive-success record-failure)
  745.                   (nconc results recursive-support-arcs)))
  746.               ;; Unsupported, operator :seq, and record-failure T:
  747.               (nconc results
  748.                      (list (make-trj-arc
  749.                             :warrant (trj-arc-warrant arc)
  750.                             :grounds (append (trj-arc-grounds arc)
  751.                                              (list (make-trj-node 
  752.                                                     :claim (first goals)
  753.                                                     :modality :unsupported
  754.                                                     :support support-arcs)))
  755.                             :bindings (trj-arc-bindings arc)))))))
  756.         (if record-failure ; it is :seq and failed
  757.           (values nil
  758.                   (list
  759.                    (make-trj-arc
  760.                     :warrant :seq
  761.                     :grounds (append (trj-arc-grounds arc)
  762.                                      (list (make-trj-node
  763.                                             :claim (first goals)
  764.                                             :modality :unsupported
  765.                                             :support nil)))
  766.                     :bindings (trj-arc-bindings arc))))
  767.           (values nil nil))
  768.         ))))
  769.  
  770. (defun SUPPORT-OR (or-goal data-dnet rules-dnet record-failure
  771.                                      include-datum-just active-bindings)
  772.   ;; Returns a list of a single TRJ arc, whose grounds correspond to disjuncts.
  773.   (declare (list or-goal active-bindings) (symbol data-dnet rules-dnet)
  774.            (optimize (safety 1) (space 2) (speed 3)))
  775.   ;; Since disjunctive, can split into separate calls for each disjunct
  776.   ;; and combine results with no worry about coordinating variables.
  777.   ;; Don't bother checking for duplicates: that is done elsewhere.
  778.   (do ((goal-ptr (cdr or-goal) (cdr goal-ptr))
  779.        (supported nil)
  780.        (grounds (list :head))
  781.        (bindings (list :head)))
  782.       ((null goal-ptr) (values supported 
  783.                                (list (make-trj-arc :warrant :or 
  784.                                                    :grounds (rest grounds)
  785.                                                    :bindings (rest bindings)))))
  786.       (declare (list goal-ptr grounds bindings))
  787.       (multiple-value-bind
  788.         (success support-arcs)
  789.         (support-arcs (first goal-ptr) data-dnet rules-dnet record-failure
  790.                       include-datum-just active-bindings)
  791.         (declare (list support-arcs))
  792.         (if success (setf supported t))
  793.         (when (or success record-failure)
  794.           (nconc grounds (list (make-trj-node
  795.                                   :claim    (first goal-ptr)
  796.                                   :modality (if success :supported :unsupported)
  797.                                   :support support-arcs)))
  798.           (nconc bindings (list (mapcar #'trj-arc-bindings support-arcs)))))))
  799.  
  800. (defun SUPPORT-LISP (forms record-failure)
  801.   (declare (list forms) (optimize (safety 1) (space 2) (speed 3)))
  802.   ;; Success depends on results; there are no bindings.
  803.   (let ((success (lisp-eval forms)))
  804.     (values success
  805.             (if (or success record-failure)
  806.               (list (make-trj-arc 
  807.                      :warrant ':lisp 
  808.                      :grounds (list (make-trj-node 
  809.                                      :claim forms
  810.                                      :modality (if success :supported :unsupported)
  811.                                      :support nil))
  812.                      :bindings nil))))))
  813.  
  814. (defun SUPPORT-BIND (variable forms)
  815.   (declare (symbol variable) (list forms) 
  816.            (optimize (safety 1) (space 2) (speed 3)))
  817.   ;; Always succeeds; return an arc that provides bindings.
  818.   (let ((result (lisp-eval forms)))
  819.     (values t
  820.             (list (make-trj-arc 
  821.                    :warrant ':bind 
  822.                    :grounds (list (make-trj-node
  823.                                    :claim forms
  824.                                    :modality ':supported
  825.                                    :support nil))
  826.                    :bindings (list (cons variable result)))))))
  827.  
  828. (defun DATUM-JUSTIFICATION-NODE (ground bindings data-dnet)
  829.   (make-trj-node :claim ground
  830.                  :modality :supported
  831.                  :support (datum-justification-arcs ground bindings data-dnet)))
  832.  
  833. (defun DATUM-JUSTIFICATION-ARCS (datum bindings data-dnet)
  834.   (mapcar #'(lambda (datum-just)
  835.               (make-trj-arc :warrant  (justification-warrant datum-just)
  836.                             :grounds  (list (datum-justification-node 
  837.                                              ;; unify may be bogus.  More correct
  838.                                              ;; to do it to the rule.
  839.                                              (justification-grounds datum-just)
  840.                                              (unify datum (justification-grounds datum-just))
  841.                                              data-dnet))
  842.                             :bindings bindings))
  843.           (datum-justification datum data-dnet)))
  844.  
  845. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  846. ;;;
  847. ;;;                        USER INTERFACE FUNCTIONS
  848. ;;;
  849. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  850.  
  851. ;;;------------------
  852. ;;; Backward Chaining
  853.  
  854. (defun SUPPORTED (goal data rules)
  855.   "supported <goal> <data> <rules>                                 [Function]
  856.   Returns non-NIL value iff <goal> is supported by <data> and <rules>."
  857.   (declare (inline retrieve-bindings))
  858.   (check-type data symbol)
  859.   (check-type rules symbol)
  860.   (assert (sm:gets 'dnet data) (data)
  861.           "[DNET:SUPPORTED] ~S is not a known DNET." data)
  862.   (assert (sm:gets 'dnet rules) (rules) 
  863.           "[DNET:SUPPORTED] ~S is not a known DNET." rules)
  864.   (if *rule-trace* (format *rule-trace* "~&---------- Call to SUPPORTED:"))
  865.   (retrieve-bindings goal data rules nil))
  866.  
  867. (defun RETRIEVE (goal data rules)
  868.   "retrieve <goal> <data> <rules>                                  [Function]
  869.   Given <goal> is a pattern, returns two values: a list of expressions
  870.   satisfying the pattern, and a list of bindings by which each expression
  871.   unifies with <goal>."
  872.   (declare (inline retrieve-bindings))
  873.   (check-type data symbol)
  874.   (check-type rules symbol)
  875.   (assert (sm:gets 'dnet data) (data) 
  876.           "[DNET:RETRIEVE] ~S is not a known DNET." data)
  877.   (assert (sm:gets 'dnet rules) (rules) 
  878.           "[DNET:RETRIEVE] ~S is not a known DNET." rules)
  879.   (if *rule-trace* (format *rule-trace* "~&---------- Call to RETRIEVE:"))
  880.   (let ((bindings nil) (results nil))
  881.     (declare (list bindings results))
  882.     ;; Get bindings for all ways the goal is met.
  883.     (dolist (binding-set (retrieve-bindings goal data rules nil))
  884.       (declare (list binding-set))
  885.       ;; Substitute unique bindings into goal to get results.
  886.       (unless (member binding-set bindings :test #'equal)
  887.           (push (substitute-bindings binding-set goal) results)
  888.           (push binding-set bindings)))
  889.     (values results bindings)))
  890.  
  891. (defvar *SUPPORT-TREE* nil 
  892.   "SUPPORT stashes the most recent root TRJ-NODE here, for debugging.")
  893.  
  894. (defun SUPPORT (goal data rules
  895.                      &key (record-failure nil) (include-datum-justification nil))
  896.   "support <goal> <data> <rules> 
  897.          &key <record-failure> <include-datum-justification>         [Function]
  898.   Given <goal> is a pattern, returns two values: a boolean T or NIL saying
  899.   whether the <goal> is supported, and a TRJ-NODE which is the root of its
  900.   support tree.  When the first value is NIL, the partial support tree is
  901.   returned only if <record-failure> is T.  If <include-datum-justification>
  902.   is T, the support tree includes justifications recorded in the <data> DNET."
  903.   (declare (inline support-arcs))
  904.   (check-type data symbol)
  905.   (check-type rules symbol)
  906.   (assert (sm:gets 'dnet data) (data) 
  907.           "[DNET:SUPPORT] ~S is not a known DNET." data)
  908.   (assert (sm:gets 'dnet rules) (rules) 
  909.           "[DNET:SUPPORT] ~S is not a known DNET." rules)
  910.   (if *rule-trace* (format *rule-trace* "~&---------- Call to SUPPORT:"))
  911.   (multiple-value-bind 
  912.     (success support-arcs)
  913.     (support-arcs goal data rules record-failure include-datum-justification nil)
  914.     (declare (list support-arcs))
  915.     (values success 
  916.             (setq *support-tree*
  917.                   (make-trj-node 
  918.                    :claim goal 
  919.                    :modality (if success :supported :unsupported) 
  920.                    :support (if (or success record-failure) support-arcs))))))
  921.  
  922. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  923. (provide :rule-back)
  924. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  925. ;;; the end.